 
C type PFPU = record
C               NAME: integer; (* index into NAMTXT *)
C               NARGS: integer;
C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
C               DTYPE: integer;
C               CHRLEN: integer;
C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
C             end;
 
C type PFEX = record
C               NAME: integer;
C               DTYPE: integer;
C               CHRLEN: integer;
C               NARGS: integer;
C               ARGS: ^(heap) HEAD(PFEXARG);
C               INDARG: ^PFPUARG    (* only for indirect refs *)
C             end;
 
C type PFPUARG = record
C                   DTYPE: integer;
C                   CHLEN: integer;
C                   case STRUC of
C                       var,array: (USAGE: (arg,read,update));
C                       proc: (REF: integer (EXNODE index))
C                       end;
C                   STRUC: (var,array,proc);
C                   SIZE: integer;
C                   DESC: ^(heap) HEAD (PUARGDES);
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   PRNTS: ^(heap) HEAD (LATPAR)
C                end;
 
C type PFEXARG = record
C                   DTYPE: integer;
C                   ATYPE: integer;
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   if (DTYPE=type_char) then
C                       CHMIN,CHMAX: integer
C                   end if
C                 end;
 
C type PFPUDESC = record
C                   NODE: integer (* +ve => index into PUNODE,
C                                    -ve => -index into EXNODE *)
C                 end;
C
C type PFPUCU = record
C                   CBNUM: integer; (* index into CBDATA *)
C                   USAGE: (readonly,update)
C               end;
 
C type PUARGDES = record
C                   TYPE: (direct,indirect);
C                   ANUM: integer;  (* argument number passed out as *)
C                   case TYPE of
C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
C                       indirect: (INUM: integer)   (* arg no. passed to *)
C                       end
C                 end;
 
C type PFPROC = record
C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
C                   ASSOC: integer; (* ditto of associating pu. *)
C                   STMTNO: integer (* statement number of association *)
C               end;
 
C
C type PARENT = record (* routine parent *)
C                   NODE: integer   (* PUNODE index of parent routine *)
C               end;
C
C type APARENT = record (* argument parent *)
C                   NODE: integer;  (* PUNODE index of parent routine *)
C                   ANUM: integer   (* argument number passed down *)
C                end;
 
C type PFUS = record (* unsafe reference check record *)
C               TYPE: 1..5;      (* unsafe reference type *)
C               ASSOC: integer;  (* punode index of calling p.u. *)
C               STMTNO: integer; (* statement number of reference *)
C               EXTRA: integer;  (* type-dependent extra data *)
C               CALLED: integer; (* punode/exnode index of called routine *)
C               ARGNUM: integer  (* argument number for unsafe check *)
C             end;
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C ----------------------------------------------------------------------
C
C       P F R E A D   -   Read PFORT information from the attribute area
C
 
        SUBROUTINE PFREAD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFWMRK/NPU,NEX
        INTEGER NPU,NEX
        SAVE /PFWMRK/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
 
        CALL PFADCB
        CALL PFADPU
        CALL PFADEN
        CALL PFADEX
        CALL PFADP2
        CALL PFADE2
        NPU=NPUS
        NEX=NEXTS
 
        END
C ----------------------------------------------------------------------
C
C       P F A D N A   -   Add a global name to the PFORT-77 database
C
C       Input argument:
C           INAME   - The name as an IST string.
C
C       Output arguments:
C           STATUS  - 0 => New name
C                     1 => Name of an existing program-unit
C                     2 => Name of an existing common block
C                     3 => Name of an existing external reference
C
C           NAMPTR  - Index into NAMTXT, except for STATUS.EQ.2, when it
C                     is an index into CBDATA.
C
 
        SUBROUTINE PFADNA(INAME,NAMPTR,STATUS)
        INTEGER INAME(*),NAMPTR,STATUS
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER I
        CHARACTER*6 NAME
 
        EXTERNAL ZITOF,ERROR
 
        CALL ZITOF(INAME,1,6,NAME,.FALSE.)
 
        DO 100 I=1,NPUS
            IF (NAMTXT(HEAP(PUNODE(I))).EQ.NAME) THEN
                STATUS=1
                NAMPTR=HEAP(PUNODE(I))
                RETURN
            END IF
 100    CONTINUE
        DO 200 I=1,NCB
            IF (NAMTXT(CBDATA(1,I)).EQ.NAME) THEN
                STATUS=2
                NAMPTR=I
                RETURN
            END IF
 200    CONTINUE
        DO 300 I=1,NEXTS
            IF (NAMTXT(HEAP(EXNODE(I))).EQ.NAME) THEN
                STATUS=3
                NAMPTR=HEAP(EXNODE(I))
                RETURN
            END IF
 300    CONTINUE
        STATUS=0
        IF (NNAMES.EQ.800) CALL ERROR('PFADNA: Too many names')
        NNAMES=NNAMES+1
        NAMTXT(NNAMES)=NAME
        NAMEPU(NNAMES)=0
        NAMPTR=NNAMES
 
        END
C ----------------------------------------------------------------------
C
C       P F A D C B   -   Add common blocks to the PFORT-77 database
C
 
        SUBROUTINE PFADCB
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
 
        INTEGER GCBPTR,COMLEN,COMTYP,COMSAV,COMINI,NAMPTR,STATUS,
     +          INAME(134),BLNKCM(8)
 
        INTEGER EQUAL
        EXTERNAL ZYXGCB,ZCHOUT,PUTLIN,ZMESS,EQUAL
 
        DATA BLNKCM/36,67,79,77,77,79,78,129/
 
        GCBPTR=-1
 100    CALL ZYXGCB(GCBPTR,INAME,COMLEN,COMTYP,COMSAV,COMINI)
        IF (GCBPTR.GE.0) THEN
            CALL PFADNA(INAME,NAMPTR,STATUS)
            IF (STATUS.NE.2 .AND. STATUS.NE.0) THEN
                CALL ZCHOUT('Error: Name clash: "',2)
                CALL PUTLIN(INAME,2)
                CALL ZCHOUT('" is both a common block & a ',2)
                IF (STATUS.EQ.1) THEN
                    CALL ZMESS('program-unit',2)
                ELSE
                    CALL ZMESS('called subprogram',2)
                END IF
            ELSE IF (STATUS.EQ.0) THEN
                IF (NCB.EQ.250)
     +              CALL ERROR ('PFADCB: Too many Common Blocks.')
                NCB=NCB+1
                CBDATA(1,NCB)=NAMPTR
                CBDATA(2,NCB)=COMLEN
                CBDATA(3,NCB)=COMTYP
                IF (COMTYP.EQ.2) CALL PFERR(
     +'E: Common block /$T/ mixes character a'//'nd numeric data',
     +                     CBDATA(1,NAMPTR),0,0,0)
                CBDATA(4,NCB)=COMSAV
                CBDATA(5,NCB)=COMINI
            ELSE IF (COMLEN.NE.CBDATA(2,NAMPTR)) THEN
                IF (EQUAL(INAME,BLNKCM).EQ.-3)
     +              CALL PFERR(
     +                  'E: Common block /$T/ has differing lengths',
     +                  CBDATA(1,NAMPTR),0,0,0)
            ELSE IF (COMINI.NE.0) THEN
                CBDATA(5,NAMPTR)=CBDATA(5,NAMPTR)+COMINI
                IF (CBDATA(5,NAMPTR).GT.1) THEN
                    CALL PFERR(
     +'E: Common block /$T/ initialised more than once',
     +                         CBDATA(1,NAMPTR),0,0,0)
                END IF
            ELSE IF (COMTYP.NE.CBDATA(3,NAMPTR) .AND.
     +               CBDATA(3,NAMPTR).NE.2) THEN
                CALL PFERR(
     +'E: Common block /$T/ mixes character a'//'nd numeric data',
     +                     CBDATA(1,NAMPTR),0,0,0)
                CBDATA(3,NAMPTR)=2
            END IF
            IF (GCBPTR.NE.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F A D P U   -   Add a program-unit node to the PFORT-77 graph
C
 
        SUBROUTINE PFADPU
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFWMRK/NPU,NEX
        INTEGER NPU,NEX
        SAVE /PFWMRK/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
 
        INTEGER GPUPTR,INAME(134),DTYPE,CHRLEN,NARGS,CULIST,I,DESC,
     +          ARG(7,60),NAMPTR,STATUS,NODE,GSYPTR,CUSAGE,TMP,
     +          PUARG(0:8-1),ELIST,CBNAME(134),COMLEN,
     +          COMTYP,COMSAV,COMINI,CBI
 
        INTEGER HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,LLCREL
        EXTERNAL ZYXGPU,ZITOF,HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,
     +           ZYXGCU,LLCREL,ZCHOUT,PUTLIN,ZMESS,LLINTO,ERROR
 
        GPUPTR=-1
 
 100    CALL ZYXGPU(GPUPTR,INAME,DTYPE,CHRLEN,NARGS,CULIST,DESC,ELIST,
     +                ARG)
        CALL PFADNA(INAME,NAMPTR,STATUS)
        IF (STATUS.EQ.2) THEN
            CALL ZCHOUT('Error: Name clash - ',2)
            CALL PUTLIN(INAME,2)
            CALL ZMESS(' is both a program unit a'//'nd a common block',
     +                 2)
        ELSE IF (STATUS.EQ.1) THEN
            CALL ZCHOUT('Error: Program unit ',2)
            CALL PUTLIN(INAME,2)
            CALL ZMESS(' occurs more than once',2)
        ELSE
            NPUS=NPUS+1
            NAMEPU(NAMPTR)=NPUS
            NODE=HALLOC(HEAP,9)
            IF (NPUS.GT.500)
     +          CALL ERROR ('PFADPU: Too many program units.')
            PUNODE(NPUS)=NODE
            HEAP(NODE+0)=NAMPTR
            HEAP(NODE+1)=NARGS
            HEAP(NODE+2)=0
            HEAP(NODE+3)=0
            HEAP(NODE+4)=0
            HEAP(NODE+8)=0
            IF (NARGS.GT.0) THEN
                HEAP(NODE+2)=LLCRHE(HEAP,0)
                DO 200 I=1,NARGS
                    PUARG(0)=ARG(1,I)
                    PUARG(1)=ARG(2,I)
                    PUARG(2)=ARG(3,I)
                    PUARG(3)=ARG(4,I)
                    PUARG(4)=ARG(5,I)
                    PUARG(5)=ARG(6,I)
                    PUARG(6)=ARG(7,I)
                    PUARG(7)=0
                    IF (PUARG(3).EQ.2)
     +                  PUARG(2)=0
                    CALL LLINTO(HEAP,
     +                          LLCRED(HEAP,8,PUARG),
     +                          HEAP(NODE+2))
 200            CONTINUE
            END IF
            IF (CULIST.NE.0) THEN
                HEAP(NODE+3)=LLCRHE(HEAP,0)
 300            CALL ZYXGCU(CULIST,GSYPTR,CUSAGE)
                CALL ZYXGCB(GSYPTR,CBNAME,COMLEN,COMTYP,COMSAV,
     +                        COMINI)
C Call PFADNA in order to obtain the COMMON block index.
                CALL PFADNA(CBNAME,CBI,STATUS)
                TMP=LLCREL(HEAP,2)
                HEAP(TMP+0)=CBI
C *** NOTE ***
C * A common block is considered to be modified if an element is passed
C * out as an actual argument to an external routine - we do not check
C * to see if the external routine modifies the argument...
C ***
C * We could of course, since we may have this information as part of
C * the unsafe reference checks, but this is too expensive to do
C * properly.
C *** END NOTE ***
                IF (ZIAND(CUSAGE,16+32+64+
     +                           65536+131072).EQ.0) THEN
                    HEAP(TMP+1)=0
                ELSE
                    HEAP(TMP+1)=1
                END IF
                CALL LLINTO(HEAP,TMP,HEAP(NODE+3))
                IF (CULIST.NE.0) GOTO 300
            END IF
            HEAP(NODE+5)=DESC
            HEAP(NODE+6)=DTYPE
            HEAP(NODE+7)=CHRLEN
        END IF
        IF (GPUPTR.GT.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F A D E N   -   Add an entry point node to the PFORT-77 graph
C
 
        SUBROUTINE PFADEN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFWMRK/NPU,NEX
        INTEGER NPU,NEX
        SAVE /PFWMRK/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
 
        INTEGER GENPTR,INAME(134),DTYPE,CHRLEN,NARGS,GPU,I,DESC,
     +          ARG(0:7-1,60),NAMPTR,STATUS,NODE,
     +          GSYPTR,CUSAGE,TMP,PUARG(0:8-1)
        CHARACTER*6 NAME
 
        INTEGER HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,LLCREL
        EXTERNAL ZITOF,HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,
     +           ZYXGCU,LLCREL,ZCHOUT,PUTLIN,ZMESS,LLINTO,ERROR
 
        GENPTR=-1
 
 100    CALL ZYXGEN(GENPTR,INAME,DTYPE,CHRLEN,NARGS,GPU,DESC,ARG)
        IF (GENPTR.EQ.-1) RETURN
        CALL PFADNA(INAME,NAMPTR,STATUS)
        IF (STATUS.EQ.2) THEN
            CALL ZCHOUT('Error: Name clash - ',2)
            CALL PUTLIN(INAME,2)
            CALL ZMESS(' is both a program unit a'//'nd a common block',
     +                 2)
        ELSE IF (STATUS.EQ.1) THEN
            CALL ZCHOUT('Error: Program unit ',2)
            CALL PUTLIN(INAME,2)
            CALL ZMESS(' occurs more than once',2)
        ELSE
            NPUS=NPUS+1
            NAMEPU(NAMPTR)=NPUS
            NODE=HALLOC(HEAP,9)
            IF (NPUS.GT.500)
     +          CALL ERROR ('PFADEN: Too many program units.')
            PUNODE(NPUS)=NODE
            HEAP(NODE+0)=NAMPTR
            HEAP(NODE+1)=NARGS
            HEAP(NODE+2)=0
            HEAP(NODE+3)=0
            HEAP(NODE+4)=0
            HEAP(NODE+8)=GPU
            IF (NARGS.GT.0) THEN
                HEAP(NODE+2)=LLCRHE(HEAP,0)
                DO 200 I=1,NARGS
                    PUARG(0)=ARG(0,I)
                    PUARG(1)=ARG(1,I)
                    PUARG(2)=ARG(2,I)
                    PUARG(3)=ARG(3,I)
                    PUARG(4)=ARG(4,I)
                    PUARG(5)=ARG(5,I)
                    PUARG(6)=ARG(6,I)
                    PUARG(7)=0
                    CALL LLINTO(HEAP,
     +                          LLCRED(HEAP,8,PUARG),
     +                          HEAP(NODE+2))
 200            CONTINUE
            END IF
            HEAP(NODE+5)=DESC
            HEAP(NODE+6)=DTYPE
            HEAP(NODE+7)=CHRLEN
        END IF
        IF (GENPTR.GT.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F A D E X   -   Add external references to the PFORT-77 graph
C
 
        SUBROUTINE PFADEX
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER GEXPTR,INAME(134),DTYPE,CHRLEN,NARGS,STATUS,NAMPTR,
     +          ARGBLK(4*60),NODE,I,ARGNOD,ARGPTR
 
        INTEGER HALLOC,LLCRHE,LLCREL
        EXTERNAL ZYXGEX,HALLOC,LLCRHE,LLCREL,LLINTO,ZCHOUT,PUTLIN,
     +           ZMESS,ERROR
 
        GEXPTR=-1
 
 100    CALL ZYXGEX(GEXPTR,INAME,DTYPE,CHRLEN,NARGS,ARGBLK)
        IF (GEXPTR.GE.0) THEN
            CALL PFADNA(INAME,NAMPTR,STATUS)
            IF (STATUS.EQ.2) THEN
                CALL ZCHOUT('Error: Name clash - ',2)
                CALL PUTLIN(INAME,2)
                CALL ZMESS(' is both a common block 38 an external '//
     +                     'reference',2)
            ELSE IF (NEXTS.EQ.500) THEN
                CALL ERROR('Too many external references')
            ELSE
                NEXTS=NEXTS+1
                NODE=HALLOC(HEAP,6)
                EXNODE(NEXTS)=NODE
                HEAP(NODE+0)=NAMPTR
                HEAP(NODE+1)=DTYPE
                HEAP(NODE+2)=CHRLEN
                HEAP(NODE+3)=NARGS
                HEAP(NODE+5)=0
                IF (NARGS.GT.0) THEN
                    HEAP(NODE+4)=LLCRHE(HEAP,0)
                    ARGPTR=1
                    DO 200 I=1,NARGS
                        DTYPE=ARGBLK(ARGPTR+0)/8+(-3)
                        IF (DTYPE.EQ.6) THEN
                            ARGNOD=LLCREL(HEAP,5)
                            HEAP(ARGNOD+0)=DTYPE
                            HEAP(ARGNOD+1)=
     +                          MOD(ARGBLK(ARGPTR+0),8)
                            HEAP(ARGNOD+2)=
     +                          ARGBLK(ARGPTR+1)
                            HEAP(ARGNOD+3)=
     +                          ARGBLK(ARGPTR+2)
                            HEAP(ARGNOD+4)=
     +                          ARGBLK(ARGPTR+3)
                            ARGPTR=ARGPTR+4
                        ELSE
                            ARGNOD=LLCREL(HEAP,3)
                            HEAP(ARGNOD+0)=DTYPE
                            HEAP(ARGNOD+1)=
     +                          MOD(ARGBLK(ARGPTR+0),8)
                            HEAP(ARGNOD+2)=
     +                          ARGBLK(ARGPTR+1)
                            ARGPTR=ARGPTR+2
                        END IF
                        CALL LLINTO(HEAP,ARGNOD,HEAP(NODE+4))
 200                CONTINUE
                END IF
            END IF
            IF (GEXPTR.GT.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F A D P 2   -   Add program-units, pass two
C
 
        SUBROUTINE PFADP2
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFWMRK/NPU,NEX
        INTEGER NPU,NEX
        SAVE /PFWMRK/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
 
        INTEGER I,DESC,ARG,REFTYP,ARGNUM,DESREC(6),PASSX,INHX,GSYPTR,
     +          ASSOC,INHTYP,STMTNO,EXTRA,ANUM,STATUS,TEXT(134)
        LOGICAL CRHEAD
 
        INTEGER ZYXGIP,ZYXGIE,LLFIRS,LLCRHE,LLCRED,LLNEXT
        EXTERNAL ZYXGGD,ZYXGIP,ZYXGIE,ZYXGPA,
     +           ZYXGIR,LLFIRS,LLCRHE,LLCRED,LLNEXT,LLINTO,
     +           ZYXGNA
 
        DO 500 I=NPU+1,NPUS
            DESC=HEAP(PUNODE(I)+5)
            HEAP(PUNODE(I)+5)=0
C Resolve pointer to actual p.u. for entry points
            IF (HEAP(PUNODE(I)+8).NE.0) THEN
                HEAP(PUNODE(I)+8)=
     +              NPU+ZYXGIP(HEAP(PUNODE(I)+8))
C And make the actual p.u. a descendent of the ENTRY point...
                HEAP(PUNODE(I)+5)=LLCRHE(HEAP,0)
                CALL LLINTO(HEAP,LLCRED(HEAP,1,HEAP(PUNODE(I)+8)),
     +                      HEAP(PUNODE(I)+5))
            END IF
            IF (DESC.NE.0) THEN
C
C Add descendent routines of the program-unit
C
 100            CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
                IF (REFTYP.EQ.1) THEN
                    CALL ZYXGNA(GSYPTR,TEXT)
                    CALL PFADNA(TEXT,DESREC(1),STATUS)
                    IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADP2-A: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                    DESREC(1)=NAMEPU(DESREC(1))
                    IF (HEAP(PUNODE(I)+5).EQ.0)
     +                  HEAP(PUNODE(I)+5)=LLCRHE(HEAP,0)
                    CALL LLINTO(HEAP,
     +                          LLCRED(HEAP,1,DESREC),
     +                          HEAP(PUNODE(I)+5))
                ELSE IF (REFTYP.EQ.2) THEN
                    DESREC(1)=-(NEX+ZYXGIE(GSYPTR))
                    IF (HEAP(PUNODE(I)+5).EQ.0)
     +                  HEAP(PUNODE(I)+5)=LLCRHE(HEAP,0)
                    CALL LLINTO(HEAP,
     +                          LLCRED(HEAP,1,DESREC),
     +                          HEAP(PUNODE(I)+5))
                ELSE IF (REFTYP.EQ.5) THEN
                    CALL PFERR(
     +'D: Indirect ref descriptor ($I) added for argument $I of $N',
     +                         GSYPTR,ARGNUM,PUNODE(I),0)
                    ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
 150                IF (ARGNUM.GT.1) THEN
                        ARG=LLNEXT(HEAP,ARG)
                        ARGNUM=ARGNUM-1
                        GOTO 150
                    END IF
                    HEAP(ARG+2)=NEX+ZYXGIE(GSYPTR)
                END IF
                IF (DESC.NE.0) GOTO 100
            END IF
            IF (HEAP(PUNODE(I)+1).GT.0) THEN
C
C For each argument, ...
C
                ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
                ANUM=1
C
C ... If this is a procedure argument, add a pointer from the procedure
C     back to the argument record
C
 200            IF (HEAP(ARG+3).EQ.2 .AND.
     +              HEAP(ARG+2).NE.0)
     +              HEAP(EXNODE(HEAP(ARG+2))+5)=ARG
                IF (HEAP(ARG+5).NE.0) THEN
C
C ... add argument descendents
C
                    PASSX=HEAP(ARG+5)
                    HEAP(ARG+5)=LLCRHE(HEAP,0)
 300                CALL ZYXGPA(PASSX,ARGNUM,DESC)
                    DESREC(1+0)=0
                    DESREC(1+1)=ARGNUM
                    CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
                    IF (REFTYP.EQ.5) THEN
                        DESREC(1+0)=1
                        DESREC(1+2)=ARGNUM
                    ELSE IF (REFTYP.EQ.1) THEN
                        CALL ZYXGNA(GSYPTR,TEXT)
                        CALL PFADNA(TEXT,DESREC(1+2),STATUS)
                        IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADP2-B: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        DESREC(1+2)=
     +                      NAMEPU(DESREC(1+2))
                    ELSE
                        IF (REFTYP.NE.2) CALL PFERR(
     +'I: Unexpected reference type ($I) in $N',REFTYP,PUNODE(I),0,0)
                        DESREC(1+2)=
     +                      -(NEX+ZYXGIE(ABS(GSYPTR)))
                    END IF
                    CALL LLINTO(HEAP,LLCRED(HEAP,3,DESREC),
     +                          HEAP(ARG+5))
                    IF (PASSX.NE.0) GOTO 300
                END IF
                IF (HEAP(ARG+6).NE.0) THEN
C
C ... add procedure arguments inherited, and unsafe reference checks
C
                    INHX=HEAP(ARG+6)
                    HEAP(ARG+6)=0
 400                CALL ZYXGIR(INHX,INHTYP,ASSOC,STMTNO,EXTRA)
                    IF (INHTYP.EQ.0) THEN
                        IF (HEAP(ARG+6).EQ.0)
     +                      HEAP(ARG+6)=LLCRHE(HEAP,0)
                        IF (EXTRA.GT.0) THEN
                            CALL ZYXGNA(EXTRA,TEXT)
                            CALL PFADNA(TEXT,DESREC(1+0),STATUS)
                            IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADP2-C: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                            DESREC(1+0)=
     +                          NAMEPU(DESREC(1+0))
                        ELSE
                            DESREC(1+0)=-NEX-ZYXGIE(-EXTRA)
                        END IF
                        CALL ZYXGNA(ASSOC,TEXT)
                        CALL PFADNA(TEXT,DESREC(1+1),STATUS)
                        IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADP2-D: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        DESREC(1+1)=NAMEPU(DESREC(1+1))
                        DESREC(1+2)=STMTNO
                        CALL LLINTO(HEAP,LLCRED(HEAP,3,DESREC),
     +                              HEAP(ARG+6))
                    ELSE
                        DESREC(1+0)=INHTYP
                        CALL ZYXGNA(ASSOC,TEXT)
                        CALL PFADNA(TEXT,DESREC(1+1),STATUS)
                        IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADP2-E: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        DESREC(1+1)=NAMEPU(DESREC(1+1))
                        DESREC(1+2)=STMTNO
                        IF (INHTYP.EQ.3) THEN
                            CALL ZYXGNA(EXTRA,TEXT)
                            CALL PFADNA(TEXT,DESREC(1+3),STATUS)
                            IF (STATUS.NE.2) CALL PFERR(
     +'I: PFADP2-F: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        ELSE
                            DESREC(1+3)=EXTRA
                        END IF
                        DESREC(1+4)=I
                        DESREC(1+5)=ANUM
                        CALL LLINTO(HEAP,LLCRED(HEAP,6,DESREC),
     +                              USHEAD)
                    END IF
                    IF (INHX.NE.0) GOTO 400
                END IF
                ARG=LLNEXT(HEAP,ARG)
                ANUM=ANUM+1
                IF (ARG.NE.0) GOTO 200
            END IF
 500    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       P F A D E 2   -   Add external references, part two
C
 
        SUBROUTINE PFADE2
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFWMRK/NPU,NEX
        INTEGER NPU,NEX
        SAVE /PFWMRK/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
 
        INTEGER I,INHX,ASSOC,DESREC(6),ARG,STMTNO,INHTYP,EXTRA,ANUM,
     +          TEXT(134),STATUS
 
        INTEGER ZYXGIE,LLCRHE,LLCRED,LLFIRS,LLNEXT
        EXTERNAL ZYXGIE,LLCRHE,LLCRED,LLFIRS,LLNEXT,ZYXGIR,
     +           LLINTO
 
        DO 300 I=NEX+1,NEXTS
            IF (HEAP(EXNODE(I)+3).GT.0) THEN
                ARG=LLFIRS(HEAP,HEAP(EXNODE(I)+4))
                ANUM=1
 100            IF (HEAP(ARG+2).NE.0) THEN
                    INHX=HEAP(ARG+2)
                    HEAP(ARG+2)=0
 200                CALL ZYXGIR(INHX,INHTYP,ASSOC,STMTNO,EXTRA)
                    IF (INHTYP.EQ.0) THEN
                        IF (HEAP(ARG+2).EQ.0)
     +                      HEAP(ARG+2)=LLCRHE(HEAP,0)
                        CALL ZYXGNA(ASSOC,TEXT)
                        CALL PFADNA(TEXT,DESREC(1+1),STATUS)
                        IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADE2-A: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        DESREC(1+1)=NAMEPU(DESREC(1+1))
                        IF (EXTRA.GT.0) THEN
                            CALL ZYXGNA(EXTRA,TEXT)
                            CALL PFADNA(TEXT,DESREC(1+0),STATUS)
                            IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADE2-B: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                            DESREC(1+0)=
     +                          NAMEPU(DESREC(1+0))
                        ELSE
                            DESREC(1+0)=-(NEX+ZYXGIE(-EXTRA))
                        END IF
                        DESREC(1+2)=STMTNO
                        CALL LLINTO(HEAP,LLCRED(HEAP,3,DESREC),
     +                              HEAP(ARG+2))
                    ELSE
                        DESREC(1+0)=INHTYP
                        CALL ZYXGNA(ASSOC,TEXT)
                        CALL PFADNA(TEXT,DESREC(1+1),STATUS)
                        IF (STATUS.NE.1) CALL PFERR(
     +'I: PFADE2-C: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        DESREC(1+1)=NAMEPU(DESREC(1+1))
                        DESREC(1+2)=STMTNO
                        IF (INHTYP.EQ.3) THEN
                            CALL ZYXGNA(EXTRA,TEXT)
                            CALL PFADNA(TEXT,DESREC(1+3),STATUS)
                            IF (STATUS.NE.2) CALL PFERR(
     +'I: PFADE2-D: unexpected return from PFADNA ($I)',STATUS,0,0,0)
                        ELSE
                            DESREC(1+3)=EXTRA
                        END IF
                        DESREC(1+4)=-I
                        DESREC(1+5)=ANUM
                        CALL LLINTO(HEAP,LLCRED(HEAP,6,DESREC),
     +                              USHEAD)
                    END IF
                    IF (INHX.NE.0) GOTO 200
                END IF
                ARG=LLNEXT(HEAP,ARG)
                ANUM=ANUM+1
                IF (ARG.NE.0) GOTO 100
            END IF
 300    CONTINUE
 
        END
